home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / arith.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  40KB  |  1,524 lines
  1. /* ******************************************************************** */
  2. /*  arith.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  arithmetic                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: arith.c,v 1.5 1992/01/09 19:10:38 pab Exp $
  9.  *
  10.  * $Log: arith.c,v $
  11.  * Revision 1.5  1992/01/09  19:10:38  pab
  12.  * Fixed for low tagged ints
  13.  *
  14.  * Revision 1.4  1991/12/22  15:13:47  pab
  15.  * Xmas revision
  16.  *
  17.  * Revision 1.3  1991/09/22  19:14:32  pab
  18.  * Fixed obvious bugs
  19.  *
  20.  * Revision 1.2  1991/09/11  11:59:29  pab
  21.  * 11/9/91 First Alpha release of modified system
  22.  *
  23.  * Revision 1.1  1991/08/12  16:49:24  pab
  24.  * Initial revision
  25.  *
  26.  * Revision 1.19  1991/03/05  19:49:29  pab
  27.  * added sqrt function
  28.  *
  29.  * Revision 1.18  1991/02/13  18:15:15  kjp
  30.  * Somethign good + RCS log headers.
  31.  *
  32.  */
  33.  
  34. /*
  35.  * Change Log:
  36.  *   Version 1, May 1989
  37.  */
  38.  
  39. #include "defs.h"
  40. #include "structs.h"
  41. #include "error.h"
  42. #include "funcalls.h"
  43.  
  44. #include "global.h"
  45. #include <math.h>
  46.  
  47. extern int abs(int);
  48.  
  49. #include "ngenerics.h"
  50. #include "modboot.h"
  51.  
  52. EUFUN_1( Fn_numberp, a)
  53. {
  54.   return (typeof(a)>=TYPE_INT && typeof(a)<=TYPE_LASTNUMBER ? lisptrue : nil);
  55. }
  56. EUFUN_CLOSE
  57.  
  58. LispObject lift_number(LispObject *stackbase, int newtype)
  59. {
  60.   LispObject a = ARG_0(stackbase);
  61.   switch(typeof(a)) 
  62.     {
  63.     case TYPE_INT:
  64.       switch (newtype) 
  65.     {
  66.     case TYPE_RATIONAL:
  67.       { LispObject one = allocate_integer(stackbase+1, 1);
  68.         a = allocate_ratio(stackbase+1, ARG_0(stackbase),one);
  69.         return a;
  70.       }      
  71.     case TYPE_FLOAT:
  72.       return allocate_float(stackbase+1,(double) (intval(a)));
  73.     case TYPE_COMPLEX:
  74.       { LispObject zero = allocate_integer(stackbase+1, 0);
  75.         a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  76.         return a;
  77.       }      
  78.     default:
  79.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  80.     }
  81.     case TYPE_RATIONAL:
  82.       switch (newtype) {
  83.       case TYPE_FLOAT: 
  84.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  85.       case TYPE_COMPLEX:
  86.     { LispObject zero = allocate_integer(stackbase+1, 0);
  87.       a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  88.       return a;
  89.     }      
  90.       default:
  91.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  92.       }
  93.     case TYPE_FLOAT:
  94.       switch (newtype) {
  95.       case TYPE_COMPLEX:
  96.     { LispObject zero = allocate_integer(stackbase, 0);
  97.       return allocate_complex(stackbase,ARG_0(stackbase), zero);
  98.     }      
  99.       case TYPE_FLOAT:
  100.     return a;
  101.       default:
  102.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  103.       }
  104.     default:
  105.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  106.     }
  107.   return nil;
  108. }
  109.  
  110. EUFUN_2(Fn_eqn, a, b)
  111. {
  112.   if (typeof(a)>typeof(b)) {
  113.     LispObject tmp = a;
  114.     a = b;
  115.     b = tmp;
  116.   }
  117.                 /* types the same is easy!! */
  118.   switch ((typeof(a)<<16)+typeof(b)) {
  119.   case (TYPE_INT<<16)+TYPE_INT:
  120.     return ((intval(a)==intval(b)) ? a : nil);
  121.   case (TYPE_INT<<16)+TYPE_RATIONAL:
  122.   case (TYPE_INT<<16)+TYPE_COMPLEX:
  123.     return nil;
  124.   case (TYPE_INT<<16)+TYPE_FLOAT:
  125.     return (((double)intval(a) == (b->FLOAT).fvalue) ? b : nil);
  126.   case (TYPE_RATIONAL<<16)+TYPE_RATIONAL:
  127.     {
  128.       LispObject ans;
  129.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).numerator,(b->RATIO).numerator);
  130.       if (ans == nil) return nil;
  131.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).denominator,(b->RATIO).denominator);
  132.       if (ans == nil) return nil;
  133.       return ARG_0(stackbase);
  134.     }
  135.   case (TYPE_RATIONAL<<16)+TYPE_FLOAT:
  136.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  137.   case (TYPE_RATIONAL<<16)+TYPE_COMPLEX:
  138.     return nil;
  139.   case (TYPE_FLOAT<<16)+TYPE_FLOAT:
  140.     return ((a->FLOAT).fvalue == (b->FLOAT).fvalue ? a : nil);
  141.   case (TYPE_FLOAT<<16)+TYPE_COMPLEX:
  142.     return nil;
  143.   case (TYPE_COMPLEX<<16)+TYPE_COMPLEX:
  144.     {
  145.       LispObject ans;
  146.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).real,(b->COMPLEX).real);
  147.       if (ans == nil) return nil;
  148.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  149.       if (ans == nil) return nil;
  150.       return ARG_0(stackbase);
  151.     }
  152.   default:
  153.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  154.   }
  155.   return nil;
  156. }
  157. EUFUN_CLOSE
  158.  
  159. EUFUN_2(Fn_plus, a, b)
  160. {
  161.   if (typeof(a)>typeof(b)) {
  162.     LispObject tmp;
  163.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  164.   }
  165.   if (typeof(a)!=typeof(b)) {
  166.     ARG_0(stacktop) = a;
  167.     a = lift_number(stacktop,typeof(b));
  168.     b = ARG_1(stackbase);
  169.   }
  170.   switch (typeof(a)) {
  171.   case TYPE_INT:
  172.     return allocate_integer(stacktop, intval(a) + intval(b));
  173.   case TYPE_RATIONAL:
  174.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  175.   case TYPE_FLOAT:
  176.     return allocate_float(stacktop,(a->FLOAT).fvalue + (b->FLOAT).fvalue);
  177.   case TYPE_COMPLEX:
  178.     {
  179.       LispObject rr;
  180.       LispObject im;
  181.       EUCALLSET_2(rr, Fn_plus, (a->COMPLEX).real, (b->COMPLEX).real);
  182.       EUCALLSET_2(im, Fn_plus, (a->COMPLEX).imaginary, (b->COMPLEX).imaginary);
  183.       return allocate_complex(stacktop,rr,im);
  184.     }
  185.   default:
  186.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  187.   }
  188.   return nil;
  189. }
  190. EUFUN_CLOSE
  191.  
  192. EUFUN_2(Fn_difference, a, b)
  193. {
  194.   if (typeof(a)!=typeof(b)) {
  195.     if (typeof(a)<typeof(b)) {
  196.       ARG_0(stacktop) = a;
  197.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  198.     }
  199.     else {
  200.       ARG_0(stacktop) = b;
  201.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  202.     }
  203.   }
  204.   switch (typeof(a)) {
  205.   case TYPE_INT:
  206.     return allocate_integer(stacktop, intval(a) - intval(b));
  207.   case TYPE_RATIONAL:
  208.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  209.   case TYPE_FLOAT:
  210.     return allocate_float(stacktop,(a->FLOAT).fvalue - (b->FLOAT).fvalue);
  211.   case TYPE_COMPLEX:
  212.     {
  213.       LispObject rr;
  214.       LispObject im;
  215.       EUCALLSET_2(rr, Fn_difference, (a->COMPLEX).real,(b->COMPLEX).real);
  216.       EUCALLSET_2(im, Fn_difference,
  217.               (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  218.       return allocate_complex(stacktop,rr,im);
  219.     }
  220.   default:
  221.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  222.   }
  223.   return nil;
  224. }
  225. EUFUN_CLOSE
  226.  
  227. EUFUN_2(Fn_times, a, b)
  228. {
  229.   if (typeof(a)>typeof(b)) {
  230.     LispObject tmp;
  231.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  232.   }
  233.   if (typeof(a)!=typeof(b)) {
  234.     ARG_0(stacktop) = a;
  235.     ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  236.   }
  237.   switch (typeof(a)) {
  238.   case TYPE_INT:
  239.     return allocate_integer(stacktop, intval(a) * intval(b));
  240.   case TYPE_RATIONAL:
  241.     {
  242.       LispObject num;
  243.       LispObject den;
  244.       EUCALLSET_2(num, Fn_times, (a->RATIO).numerator,(b->RATIO).numerator);
  245.       EUCALLSET_2(den, Fn_times,(a->RATIO).denominator,(b->RATIO).denominator);
  246.       return allocate_ratio(stackbase, num,den); /* Should reduce this */
  247.     }
  248.   case TYPE_FLOAT:
  249.     return allocate_float(stackbase,(a->FLOAT).fvalue * (b->FLOAT).fvalue);
  250.   case TYPE_COMPLEX:
  251.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  252.   default:
  253.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  254.   }
  255.   return nil;
  256. }
  257. EUFUN_CLOSE
  258.  
  259. EUFUN_2(Fn_divide, a, b)
  260. {
  261.   if (typeof(a)<typeof(b)) {
  262.       ARG_0(stacktop) = a;
  263.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  264.     }
  265.   else if (typeof(a)>typeof(b)) {
  266.       ARG_0(stacktop) = b;
  267.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  268.     }
  269.  
  270.   /* Types are equivalent... */
  271.  
  272.   switch(typeof(a)) {
  273.  
  274.   case TYPE_INT:
  275.     return((LispObject) allocate_integer(stackbase, intval(a) / intval(b)));
  276.   case TYPE_RATIONAL:
  277.     {
  278.       LispObject num;
  279.       LispObject den;
  280.       EUCALLSET_2(num, Fn_times,a->RATIO.numerator,b->RATIO.denominator);
  281.       EUCALLSET_2(den, Fn_times,a->RATIO.denominator,b->RATIO.numerator);
  282.       return(allocate_ratio(stackbase,num,den)); /* Not canonical... */
  283.     }
  284.   case TYPE_FLOAT:
  285.     return(allocate_float(stackbase,a->FLOAT.fvalue / b->FLOAT.fvalue));
  286.   case TYPE_COMPLEX:
  287.   default:
  288.     CallError(stacktop,"kernel /: unimplemented facility",a,NONCONTINUABLE);
  289.  
  290.   }
  291.  
  292.   return(nil);
  293. }
  294. EUFUN_CLOSE
  295.  
  296. EUFUN_2(Fn_lessp, a, b)
  297. {
  298.   if (typeof(a)!=typeof(b)) {
  299.   if (typeof(a)<typeof(b)) {
  300.       ARG_0(stacktop) = a;
  301.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  302.     }
  303.   else {
  304.       ARG_0(stacktop) = b;
  305.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  306.     }
  307.   }
  308.   switch (typeof(a)) {
  309.   case TYPE_INT:
  310.     return (intval(a) < intval(b) ? lisptrue : nil);
  311.   case TYPE_RATIONAL:
  312.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  313.   case TYPE_FLOAT:
  314.     return ((a->FLOAT).fvalue < (b->FLOAT).fvalue ? lisptrue : nil);
  315.   case TYPE_COMPLEX:
  316.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  317.   default:
  318.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  319.   }
  320.   return nil;
  321. }
  322. EUFUN_CLOSE
  323.  
  324. EUFUN_2(Fn_greaterp, a, b)
  325. {
  326.   if (Fn_lessp(stackbase) == nil && Fn_eqn(stackbase) == nil)
  327.     return(lisptrue);
  328.   else
  329.     return(nil);
  330. }
  331. EUFUN_CLOSE
  332.  
  333. LispObject generic_zerop;
  334.  
  335. EUFUN_1( Gf_zerop, i)
  336. {
  337.   return(generic_apply_1(stackbase, generic_zerop,i));
  338. }
  339. EUFUN_CLOSE
  340.  
  341. EUFUN_1( Fn_zerop, a)
  342. {
  343.   switch (typeof(a)) {
  344.   case TYPE_INT:
  345.     return (intval(a) == 0 ? lisptrue : nil);
  346.   case TYPE_BIGNUM:
  347.     return nil;
  348.   case TYPE_RATIONAL:
  349.     ARG_0(stackbase) = (a->RATIO).numerator;
  350.     return Fn_zerop(stackbase);
  351.   case TYPE_FLOAT:
  352.     return ((a->FLOAT).fvalue == (double)0.0E0 ? lisptrue : nil);
  353.   case TYPE_COMPLEX:
  354.     ARG_0(stacktop) = (a->COMPLEX).real;
  355.     if (Fn_zerop(stacktop)==nil) return nil;
  356.     ARG_0(stackbase) = (a->COMPLEX).imaginary;
  357.     return Fn_zerop(stackbase);
  358.   default:
  359.     CallError(stacktop,"Unimplemented facility in zerop",a,NONCONTINUABLE);
  360.   }
  361.   return nil;
  362. }
  363. EUFUN_CLOSE
  364.  
  365. EUFUN_1( Md_zerop_Number, a)
  366. {
  367.   return Fn_zerop(stackbase);
  368. }
  369. EUFUN_CLOSE
  370.  
  371. LispObject generic_abs;
  372.  
  373. EUFUN_1( Gf_abs, i)
  374. {
  375.   return(generic_apply_1(stackbase, generic_abs, i));
  376. }
  377. EUFUN_CLOSE
  378.  
  379. EUFUN_1( Fn_abs,  a)
  380. {
  381.   switch (typeof(a)) {
  382.   case TYPE_INT:
  383.     return (intval(a) < 0 ?
  384.          allocate_integer(stackbase, -intval(a)) : a);
  385.   case TYPE_BIGNUM:
  386.     return nil;
  387.   case TYPE_RATIONAL:
  388.     ARG_0(stacktop) = (a->RATIO).numerator;
  389.     return allocate_ratio(stackbase, Fn_abs(stacktop),(a->RATIO).denominator);
  390.   case TYPE_FLOAT:
  391.     return ((a->FLOAT).fvalue >= (double)0.0E0 ? a :
  392.         allocate_float(stackbase,-(a->FLOAT).fvalue));
  393.   case TYPE_COMPLEX:
  394.     {
  395.       LispObject r = (a->COMPLEX).real;
  396.       LispObject i = (a->COMPLEX).imaginary;
  397.       ARG_0(stacktop) = r;
  398.       ARG_1(stacktop) = r;
  399.       ARG_0(stackbase) = Fn_times(stacktop);
  400.       ARG_0(stacktop) = i;
  401.       ARG_1(stacktop) = i;
  402.       ARG_1(stackbase) = Fn_times(stacktop);
  403.       ARG_0(stackbase) = Fn_plus(stackbase);
  404.       a = lift_number(stackbase, TYPE_FLOAT);
  405.       return allocate_float(stackbase,sqrt((a->FLOAT).fvalue));
  406.     }
  407.   default:
  408.     CallError(stacktop,"Unimplemented facility in abs",a,NONCONTINUABLE);
  409.   }
  410.   return nil;
  411. }
  412. EUFUN_CLOSE
  413.  
  414. EUFUN_1( Md_abs_Number, a)
  415. {
  416.   return Fn_abs(stackbase);
  417. }
  418. EUFUN_CLOSE
  419.  
  420. /* *************************************************************** */
  421. /* Integer Arithmetic                                              */
  422. /* *************************************************************** */
  423.  
  424. EUFUN_1( Fn_fixnump, form)
  425. {
  426.   return (is_fixnum(form) ? lisptrue : nil);
  427. }
  428. EUFUN_CLOSE
  429.  
  430. EUFUN_1( Fn_oddp, form)
  431. {
  432.   while (!is_fixnum(form))
  433.     form = CallError(stacktop,"Not an integer in oddp ",form,CONTINUABLE);
  434.   return ((intval(form)) & 1 ==0 ? nil : lisptrue);
  435. }
  436. EUFUN_CLOSE
  437.  
  438. EUFUN_1( Fn_evenp, form)
  439. {
  440.   while (!is_fixnum(form))
  441.     form = CallError(stacktop,"Not an integer in evenp ",form,CONTINUABLE);
  442.   return ((intval(form)) & 1 != 0 ? nil : lisptrue);
  443. }
  444. EUFUN_CLOSE
  445.  
  446. /* *************************************************************** */
  447. /* Floating Point Arithmetic                                       */
  448. /* *************************************************************** */
  449.  
  450. EUFUN_1( Fn_floatp, form)
  451. {
  452.   return (is_float(form) ? lisptrue : nil);
  453. }
  454. EUFUN_CLOSE
  455.  
  456. EUFUN_1( Fn_floor, form)
  457. {
  458.   double n;
  459.  
  460.   while (!is_number(form))
  461.     form = CallError(stacktop,"Not a number in floor ",form,CONTINUABLE);
  462.   form = lift_number(stackbase, TYPE_FLOAT);
  463.   n = floor((form->FLOAT).fvalue);
  464.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  465.     return allocate_integer(stackbase, (int)n);
  466.   fprintf(stderr,"Floor to a bignum missing\n");
  467.   return nil;
  468. }
  469. EUFUN_CLOSE
  470.  
  471. EUFUN_1( Fn_ceiling, form)
  472. {
  473.   double n;
  474.  
  475.   while (!is_number(form))
  476.     form = CallError(stacktop,"Not a number in ceiling ",form,CONTINUABLE);
  477.   form = lift_number(stackbase, TYPE_FLOAT);
  478.   n = ceil((form->FLOAT).fvalue);
  479.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  480.     return allocate_integer(stackbase, (int)n);
  481.   fprintf(stderr,"Ceiling to a bignum missing\n");
  482.   return nil;
  483. }
  484. EUFUN_CLOSE
  485.  
  486. EUFUN_1( Fn_truncate, f)
  487. {
  488.   if (is_fixnum(f)) return(f);
  489.   if (is_float(f)) {
  490.     long down;
  491.  
  492.     down = (long) floor(f->FLOAT.fvalue);
  493.     if ((double) abs((int) down) > f->FLOAT.fvalue) down += 1;
  494.     return (LispObject) allocate_integer(stackbase, (int) down);
  495.   }
  496.   CallError(stacktop,"truncate: no way",f,NONCONTINUABLE);
  497.  
  498.   return(nil);
  499. }
  500. EUFUN_CLOSE
  501.  
  502. EUFUN_1( Fn_round, f)
  503. {
  504.   if (is_fixnum(f)) return(f);
  505.   if (is_float(f)) {
  506.     long down;
  507.  
  508.     down = (long) floor(f->FLOAT.fvalue + (double) 0.5);
  509.     return (LispObject) allocate_integer(stackbase, (int) down);
  510.   }
  511.   CallError(stacktop,"round: no way",f,NONCONTINUABLE);
  512.  
  513.   return(nil);
  514. }
  515. EUFUN_CLOSE  
  516.     
  517. /* *************************************************************** */
  518. /* Floating Point Arithmetic                                       */
  519. /* *************************************************************** */
  520.  
  521. EUFUN_1( Fn_cos, form)
  522. {
  523.   while (!is_number(form))
  524.     form = CallError(stacktop,"Not a number in cos ",form,CONTINUABLE);
  525.   form = lift_number(stackbase, TYPE_FLOAT);
  526.   return allocate_float(stackbase,cos((form->FLOAT).fvalue));
  527. }
  528. EUFUN_CLOSE 
  529.  
  530. EUFUN_1( Fn_sin, form)
  531. {
  532.   while (!is_number(form))
  533.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  534.   form = lift_number(stackbase, TYPE_FLOAT);
  535.   return allocate_float(stackbase,sin((form->FLOAT).fvalue));
  536. }
  537. EUFUN_CLOSE
  538.  
  539. EUFUN_1( Fn_sqrt, form)
  540. {
  541.   while (!is_number(form))
  542.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  543.   form = lift_number(stackbase, TYPE_FLOAT);
  544.   return allocate_float(stackbase,sqrt((form->FLOAT).fvalue));
  545. }
  546. EUFUN_CLOSE
  547.   
  548. EUFUN_1( Fn_exp, form)
  549. {
  550.   while (!is_number(form))
  551.     form = CallError(stacktop,"Not a number in exp ",form,CONTINUABLE);
  552.   form = lift_number(stackbase, TYPE_FLOAT);
  553.   return allocate_float(stackbase,exp((form->FLOAT).fvalue));
  554. }
  555. EUFUN_CLOSE
  556.  
  557.                 /* This function does not check correctly */
  558. EUFUN_1( Fn_log, form)
  559. {
  560.   LispObject base, arg1;
  561.   while (!is_cons(form))
  562.     form = CallError(stacktop,"No argument(s) to log ",form,CONTINUABLE);
  563.   arg1 = CAR(form);
  564.   while (!is_number(arg1))
  565.     ARG_0(stacktop) = CallError(stacktop,"Not a number in log ",arg1,CONTINUABLE);
  566.   arg1 = lift_number(stacktop, TYPE_FLOAT);
  567.   if (is_cons(CDR(form))) {
  568.     base = CAR(CDR(form));
  569.     while (!is_number(base))
  570.       base = CallError(stacktop,"Not a base in log ",base,CONTINUABLE);
  571.     ARG_0(stacktop) = arg1;
  572.     ARG_1(stacktop) = arg1;
  573.     base = lift_number(stacktop+1, TYPE_FLOAT);
  574.     return
  575.       allocate_float(stackbase,
  576.              log((arg1->FLOAT).fvalue) / log((base->FLOAT).fvalue));
  577.   }
  578.   else
  579.     return allocate_float(stackbase,log((arg1->FLOAT).fvalue));
  580. }
  581. EUFUN_CLOSE
  582.  
  583. EUFUN_1( Fn_acos, form)
  584. {
  585.   while (!is_number(form))
  586.     form = CallError(stacktop,"Not a number in acos ",form,CONTINUABLE);
  587.   form = lift_number(stackbase, TYPE_FLOAT);
  588.   return allocate_float(stackbase,acos((form->FLOAT).fvalue));
  589. }
  590. EUFUN_CLOSE
  591.  
  592. EUFUN_1( Fn_asin, form)
  593. {
  594.   while (!is_number(form))
  595.     form = CallError(stacktop,"Not a number in asin ",form,CONTINUABLE);
  596.   form = lift_number(stackbase, TYPE_FLOAT);
  597.   return allocate_float(stacktop,asin((form->FLOAT).fvalue));
  598. }
  599. EUFUN_CLOSE
  600.  
  601. EUFUN_1( Fn_atan, form)
  602. {
  603.   while (!is_number(form))
  604.     form = CallError(stacktop,"Not a number in atan ",form,CONTINUABLE);
  605.   form = lift_number(stackbase, TYPE_FLOAT);
  606.   return allocate_float(stacktop,atan((form->FLOAT).fvalue));
  607. }
  608. EUFUN_CLOSE
  609.  
  610. EUFUN_2( Fn_atan2, form1, form2)
  611. {
  612.   while (!is_number(form1))
  613.     form1 = CallError(stacktop,"Not a number in atan2 ",form1,CONTINUABLE);
  614.   ARG_0(stacktop) = form1;
  615.   ARG_0(stackbase) = lift_number(stacktop, TYPE_FLOAT);
  616.   while (!is_number(form2))
  617.     form2 = CallError(stacktop,"Not a number in atan2 ",form2,CONTINUABLE);
  618.   form2 = lift_number(stackbase+1, TYPE_FLOAT);
  619.   form1 = ARG_0(stackbase);
  620.   return allocate_float(stacktop,
  621.             atan2((form1->FLOAT).fvalue,(form2->FLOAT).fvalue));
  622. }
  623. EUFUN_CLOSE
  624.  
  625. EUFUN_1( Fn_tan, form)
  626. {
  627.   while (!is_number(form))
  628.     form = CallError(stacktop,"Not a number in tan ",form,CONTINUABLE);
  629.   form = lift_number(stackbase, TYPE_FLOAT);
  630.   return allocate_float(stacktop,tan((form->FLOAT).fvalue));
  631. }
  632. EUFUN_CLOSE
  633.  
  634. EUFUN_1( Fn_acosh, form)
  635. {
  636.   double x;
  637.   while (!is_number(form))
  638.     form = CallError(stacktop,"Not a number in acosh ",form,CONTINUABLE);
  639.   form = lift_number(stackbase, TYPE_FLOAT);
  640.   x = (form->FLOAT).fvalue;
  641.   return allocate_float(stackbase,log(x+sqrt(x*x-1)));
  642. }
  643. EUFUN_CLOSE
  644.  
  645. EUFUN_1( Fn_asinh, form)
  646. {
  647.   double x;
  648.   while (!is_number(form))
  649.     form = CallError(stacktop,"Not a number in asinh ",form,CONTINUABLE);
  650.   form = lift_number(stackbase, TYPE_FLOAT);
  651.   x = (form->FLOAT).fvalue;
  652.   return allocate_float(stackbase,log(x+sqrt(x*x+1)));
  653. }
  654. EUFUN_CLOSE
  655.  
  656. EUFUN_1( Fn_atanh, form)
  657. {
  658.   double x;
  659.   while (!is_number(form))
  660.     form = CallError(stacktop,"Not a number in atanh ",form,CONTINUABLE);
  661.   form = lift_number(stackbase, TYPE_FLOAT);
  662.   x = (form->FLOAT).fvalue;
  663.   return allocate_float(stackbase,0.5*(log((x+1.0)/(x-1.0))));
  664. }
  665. EUFUN_CLOSE
  666.  
  667. EUFUN_1( Fn_cosh, form)
  668. {
  669.   while (!is_number(form))
  670.     form = CallError(stacktop,"Not a number in cosh ",form,CONTINUABLE);
  671.   form = lift_number(stackbase, TYPE_FLOAT);
  672.   return allocate_float(stackbase,cosh((form->FLOAT).fvalue));
  673. }
  674. EUFUN_CLOSE
  675.  
  676. EUFUN_1( Fn_sinh, form)
  677. {
  678.   while (!is_number(form))
  679.     form = CallError(stacktop,"Not a number in sinh ",form,CONTINUABLE);
  680.   form = lift_number(stackbase, TYPE_FLOAT);
  681.   return allocate_float(stackbase,sinh((form->FLOAT).fvalue));
  682. }
  683. EUFUN_CLOSE
  684.  
  685. EUFUN_1( Fn_tanh, form)
  686. {
  687.   while (!is_number(form))
  688.     form = CallError(stacktop,"Not a number in tanh ",form,CONTINUABLE);
  689.   form = lift_number(stackbase, TYPE_FLOAT);
  690.   return allocate_float(stackbase,tanh((form->FLOAT).fvalue));
  691. }
  692. EUFUN_CLOSE
  693.  
  694. /* Generic versions... */
  695.  
  696. LispObject generic_eqn;
  697.  
  698. EUFUN_2(Gf_eqn, i1, i2)
  699. {
  700.   return(generic_apply_2(stackbase, generic_eqn, i1, i2));
  701. }
  702. EUFUN_CLOSE
  703.  
  704. EUFUN_2(Md_eqn_Number_Number, i1, i2)
  705. {
  706.   return(Fn_eqn(stackbase));
  707. }
  708. EUFUN_CLOSE
  709.  
  710. LispObject generic_binary_plus;
  711.  
  712. EUFUN_2(Gf_binary_plus, a, b)
  713. {
  714.   return(generic_apply_2(stackbase, generic_binary_plus, a, b));
  715. }
  716. EUFUN_CLOSE
  717.  
  718. EUFUN_2(Md_binary_plus_Object_Object, n1, n2)
  719. {
  720.   return(Fn_plus(stackbase));
  721. }
  722. EUFUN_CLOSE
  723.  
  724. EUFUN_2( Md_binary_plus_Integer_Integer, i1, i2)
  725. {
  726.   return((LispObject)allocate_integer(stackbase, intval(i1)+intval(i2)));
  727. }
  728. EUFUN_CLOSE
  729.  
  730. LispObject generic_binary_difference;
  731.  
  732. EUFUN_2( Gf_binary_difference, a, b)
  733. {
  734.   return(generic_apply_2(stackbase, generic_binary_difference,a, b));
  735. }
  736. EUFUN_CLOSE
  737.  
  738. EUFUN_2( Md_binary_difference_Object_Object, n1, n2)
  739. {
  740.   return(Fn_difference(stackbase));
  741. }
  742. EUFUN_CLOSE
  743.  
  744. EUFUN_2( Md_binary_difference_Integer_Integer, i1, i2)
  745. {
  746.   return((LispObject)allocate_integer(stackbase, intval(i1)-intval(i2)));
  747. }
  748. EUFUN_CLOSE
  749.  
  750. LispObject generic_binary_times;
  751.  
  752. EUFUN_2( Gf_binary_times, a, b)
  753. {
  754.   return(generic_apply_2(stackbase, generic_binary_times, a, b));
  755. }
  756. EUFUN_CLOSE
  757.  
  758. EUFUN_2( Md_binary_times_Object_Object, n1, n2)
  759. {
  760.   return(Fn_times(stackbase));
  761. }
  762. EUFUN_CLOSE
  763.  
  764. EUFUN_2( Md_binary_times_Integer_Integer, i1, i2)
  765. {
  766.   return((LispObject)allocate_integer(stackbase, intval(i1)*intval(i2)));
  767. }
  768. EUFUN_CLOSE
  769.  
  770. LispObject generic_binary_divide;
  771.  
  772. EUFUN_2( Gf_binary_divide, a, b)
  773. {
  774.   return(generic_apply_2(stackbase, generic_binary_divide, a, b));
  775. }
  776. EUFUN_CLOSE
  777.  
  778. EUFUN_2( Md_binary_divide_Object_Object, n1, n2)
  779. {
  780.   return(Fn_divide(stackbase));
  781. }
  782. EUFUN_CLOSE
  783.  
  784. EUFUN_2( Md_binary_divide_Integer_Integer, i1, i2)
  785. {
  786.   return((LispObject) allocate_integer(stacktop, intval(i1)/intval(i2)));
  787. }
  788. EUFUN_CLOSE
  789.  
  790. /* Wrappers... */
  791.  
  792. EUFUN_1( Fn_nary_plus, args)
  793. {
  794.   LispObject walker;
  795.   LispObject n1,n2;
  796.  
  797.   walker = args;
  798.  
  799.   if (!is_cons(walker))
  800.     CallError(stacktop,"+: no arguments",args,NONCONTINUABLE);
  801.  
  802.   n1 = CAR(walker); walker = CDR(walker);
  803.  
  804.   if (!is_cons(walker))
  805.     CallError(stacktop,"+: insufficient arguments",args,NONCONTINUABLE);
  806.  
  807.   n2 = CAR(walker); walker = CDR(walker);
  808.   n1 = generic_apply_2(stacktop, generic_binary_plus, n1, n2);
  809.  
  810.   while (is_cons(walker)) {
  811.     STACK_TMP(CDR(walker));
  812.     n1 = generic_apply_2(stacktop, generic_binary_plus, n1, CAR(walker));
  813.     UNSTACK_TMP(walker);
  814.   }
  815.  
  816.   return(n1);
  817. }
  818. EUFUN_CLOSE
  819.  
  820. EUFUN_1( Fn_nary_difference, args)
  821. {
  822.   LispObject walker;
  823.   LispObject n1,n2;
  824.  
  825.   walker = args;
  826.  
  827.   if (!is_cons(walker))
  828.     CallError(stacktop,"-: no arguments",args,NONCONTINUABLE);
  829.  
  830.   n1 = CAR(walker); walker = CDR(walker);
  831.  
  832.   if (!is_cons(walker)) {
  833.     LispObject xx;
  834.     STACK_TMP(n1);
  835.     xx = allocate_integer(stacktop, 0);
  836.     UNSTACK_TMP(n1);
  837.     return(generic_apply_2(stackbase, generic_binary_difference,xx, n1));
  838.   }
  839.  
  840.   n2 = CAR(walker); STACK_TMP(CDR(walker));
  841.   n1 = generic_apply_2(stacktop, generic_binary_difference,n1, n2);
  842.   UNSTACK_TMP(walker);
  843.  
  844.   while (is_cons(walker)) {
  845.     STACK_TMP(CDR(walker));
  846.     n1 = generic_apply_2(stacktop, generic_binary_difference,n1, CAR(walker));
  847.     UNSTACK_TMP(walker);
  848.   }
  849.  
  850.   return(n1);
  851. }
  852. EUFUN_CLOSE
  853.  
  854. EUFUN_1( Fn_nary_times, args)
  855. {
  856.   LispObject walker;
  857.   LispObject n1,n2;
  858.  
  859.   walker = args;
  860.  
  861.   if (!is_cons(walker))
  862.     CallError(stacktop,"*: no arguments",args,NONCONTINUABLE);
  863.  
  864.   n1 = CAR(walker); walker = CDR(walker);
  865.  
  866.   if (!is_cons(walker))
  867.     CallError(stacktop,"*: insufficient arguments",args,NONCONTINUABLE);
  868.  
  869.   STACK_TMP(CDR(walker));
  870.   n1 = generic_apply_2(stacktop, generic_binary_times, n1, CAR(walker));
  871.   UNSTACK_TMP(walker);
  872.  
  873.   while (is_cons(walker)) {
  874.     STACK_TMP(CDR(walker));
  875.     n1 = generic_apply_2(stacktop, generic_binary_times,n1, CAR(walker));
  876.     UNSTACK_TMP(walker);
  877.   }
  878.  
  879.   return(n1);
  880. }
  881. EUFUN_CLOSE
  882.  
  883. EUFUN_1( Fn_nary_divide, args)
  884. {
  885.   LispObject walker;
  886.   LispObject n1,n2;
  887.  
  888.   walker = args;
  889.  
  890.   if (!is_cons(walker))
  891.     CallError(stacktop,"/: no arguments",args,NONCONTINUABLE);
  892.  
  893.   n1 = CAR(walker); walker = CDR(walker);
  894.  
  895.   if (!is_cons(walker))
  896.     CallError(stacktop,"/: insufficient arguments",args,NONCONTINUABLE);
  897.  
  898.   STACK_TMP(CDR(walker));
  899.   n1 = generic_apply_2(stacktop, generic_binary_divide, n1, CAR(walker));
  900.   UNSTACK_TMP(walker);
  901.  
  902.   while (is_cons(walker)) {
  903.     STACK_TMP(CDR(walker));
  904.     n1 = generic_apply_2(stacktop, generic_binary_divide,n1, CAR(walker));
  905.     UNSTACK_TMP(walker);
  906.   }
  907.  
  908.   return(n1);
  909. }
  910. EUFUN_CLOSE
  911.  
  912. /*
  913.  * Integer operations...
  914.  */
  915.  
  916. EUFUN_2(Fn_quotient, n, m)
  917. {
  918.   if (!is_fixnum(n))
  919.     CallError(stacktop,"quotient: not an integer",n,NONCONTINUABLE);
  920.  
  921.   if (!is_fixnum(m))
  922.     CallError(stacktop,"quotient: not an integer",m,NONCONTINUABLE);
  923.  
  924.   return((LispObject) allocate_integer(stackbase, intval(n)/intval(m)));
  925. }
  926. EUFUN_CLOSE
  927.  
  928. EUFUN_2(Fn_remainder, n, m)
  929. {
  930.  
  931.   if (!is_fixnum(n))
  932.     CallError(stacktop,"remainder(hack): non-integer as argument",n,NONCONTINUABLE);
  933.  
  934.   if (!is_fixnum(m))
  935.     CallError(stacktop,"remainder(hack): non-integer as argument",m,NONCONTINUABLE);
  936.  
  937.   return((LispObject) allocate_integer(stackbase, intval(n)%intval(m)));
  938.  
  939. }
  940. EUFUN_CLOSE
  941.  
  942. /*
  943.  * GCD calculation.
  944.  */
  945.  
  946. LispObject generic_binary_gcd;
  947.  
  948. EUFUN_2(Gf_binary_gcd, n1, n2)
  949. {
  950.   return(generic_apply_2(stackbase, generic_binary_gcd,n1, n2));
  951. }
  952. EUFUN_CLOSE
  953.  
  954. EUFUN_2( Md_binary_gcd_Integer_Integer, n1, n2)
  955. {
  956.   extern int abs(int);
  957.   int a,b,r;
  958.   LispObject ans;
  959.  
  960.   a = abs(intval(n1)); b = abs(intval(n2));
  961.  
  962.   do {
  963.     
  964.     r = a%b;
  965.     a = b; b = r;
  966.  
  967.   } while(b != 0);
  968.  
  969.   return (LispObject) allocate_integer(stackbase, a);
  970.  
  971.   return(ans);
  972. }
  973. EUFUN_CLOSE
  974.  
  975. EUFUN_1( Fn_gcd, args)
  976. {
  977.   LispObject v1,v2;
  978.  
  979.   if (intval(Fn_length(stackbase)) < 2)
  980.     CallError(stacktop,"gcd: insufficient arguments",args,NONCONTINUABLE);
  981.   
  982.   v1 = CAR(args); args = CDR(args);
  983.  
  984.   while (is_cons(args)) {
  985.  
  986.     ARG_0(stacktop) = v1;
  987.     ARG_1(stacktop)= v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  988.     v1 = Gf_binary_gcd(stacktop);
  989.     args = ARG_0(stackbase);
  990.     
  991.   }
  992.  
  993.   return(v1);
  994. }
  995. EUFUN_CLOSE
  996.  
  997. /*
  998.  * LCM calculation.
  999.  */
  1000.  
  1001. LispObject generic_binary_lcm;
  1002.  
  1003. EUFUN_2(Gf_binary_lcm, n1, n2)
  1004. {
  1005.   return(generic_apply_2(stackbase, generic_binary_lcm, n1, n2));
  1006. }
  1007. EUFUN_CLOSE
  1008.  
  1009. EUFUN_2( Md_binary_lcm_Integer_Integer, n1, n2)
  1010. {
  1011.   extern int abs(int);
  1012.   int a,b,r,origa,origb;
  1013.  
  1014.   a = abs(intval(n1)); b = abs(intval(n2));
  1015.   origa = a; origb = b;
  1016.   do {
  1017.     r = a%b;
  1018.     a = b; b = r;
  1019.   } while(b != 0);
  1020.  
  1021.   a = (origa/a)*origb;
  1022.   return (LispObject) allocate_integer(stackbase, a);
  1023. }
  1024. EUFUN_CLOSE
  1025.  
  1026. EUFUN_1( Fn_lcm, args)
  1027. {
  1028.   LispObject v1,v2;
  1029.   
  1030.   if (intval(Fn_length(stackbase)) < 2)
  1031.     CallError(stacktop,"lcm: insufficient arguments",args,NONCONTINUABLE);
  1032.   v1 = CAR(args); args = CDR(args);
  1033.   while (is_cons(args)) {
  1034.     ARG_0(stacktop) = v1;
  1035.     ARG_1(stacktop) = v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  1036.     v1 = Gf_binary_lcm(stacktop);
  1037.     args = ARG_0(stackbase);
  1038.   }
  1039.  
  1040.   return(v1);
  1041. }
  1042. EUFUN_CLOSE
  1043.  
  1044. /* *************************************************************** */
  1045. /*                           Ordering                              */
  1046. /* *************************************************************** */  
  1047.  
  1048. LispObject generic_binary_lt;
  1049.  
  1050. EUFUN_2(Gf_binary_lt, a, b)
  1051. {
  1052.   return(generic_apply_2(stackbase, generic_binary_lt, a, b));
  1053. }
  1054. EUFUN_CLOSE
  1055.  
  1056. EUFUN_2(Md_binary_lt_Number, a, b)
  1057. {
  1058.   return(Fn_lessp(stackbase));
  1059. }
  1060. EUFUN_CLOSE
  1061.  
  1062. EUFUN_2(Md_binary_lt_Integer, a, b)
  1063. {
  1064.   return(intval(a)<intval(b) ? lisptrue : nil);
  1065. }
  1066. EUFUN_CLOSE
  1067.  
  1068.  
  1069. EUFUN_1( Fn_lt, args)
  1070. {
  1071.   LispObject a;
  1072.  
  1073.   if (!is_cons(args))
  1074.     CallError(stacktop,"<: insufficient arguments",args,NONCONTINUABLE);
  1075.  
  1076.   a = CAR(args); args = CDR(args);
  1077.   
  1078.   if (!is_cons(args)) return(lisptrue);
  1079.  
  1080.   while (is_cons(args)) {
  1081.     ARG_0(stacktop) = a;
  1082.     ARG_1(stacktop) = CAR(args);
  1083.     if (Gf_binary_lt(stacktop) == nil) return(nil);
  1084.     a = CAR(args);
  1085.     args = CDR(args);
  1086.     ARG_0(stackbase) = args;
  1087.   }
  1088.  
  1089.   return(lisptrue);
  1090. }
  1091. EUFUN_CLOSE
  1092.  
  1093.  
  1094. LispObject generic_binary_gt;
  1095.  
  1096. EUFUN_2(Gf_binary_gt, a, b)
  1097. {
  1098.   return(generic_apply_2(stackbase, generic_binary_gt,a, b));
  1099. }
  1100. EUFUN_CLOSE
  1101.  
  1102. EUFUN_2(Md_binary_gt_Number, a, b)
  1103. {
  1104.   ARG_0(stackbase) = b;
  1105.   ARG_1(stackbase) = a;
  1106.   return(Gf_binary_lt(stackbase));
  1107. }
  1108. EUFUN_CLOSE
  1109.  
  1110. EUFUN_2(Md_binary_gt_Integer, a, b)
  1111. {
  1112.   return(intval(a)>intval(b) ? lisptrue : nil);
  1113. }
  1114. EUFUN_CLOSE
  1115.  
  1116. EUFUN_1( Fn_gt, args)
  1117. {
  1118.   LispObject a;
  1119.  
  1120.   if (!is_cons(args))
  1121.     CallError(stacktop,">: insufficient arguments",args,NONCONTINUABLE);
  1122.  
  1123.   a = CAR(args); args = CDR(args);
  1124.   
  1125.   if (!is_cons(args)) return(lisptrue);
  1126.  
  1127.   while (is_cons(args)) {
  1128.     ARG_0(stacktop) = a;
  1129.     ARG_1(stacktop) = CAR(args);
  1130.     if (Gf_binary_gt(stacktop) == nil) return(nil);
  1131.     a = CAR(args);
  1132.     args = CDR(args);
  1133.     ARG_0(stackbase) = args;
  1134.   }
  1135. #ifdef jpff_version /* Fri Sep  6 17:51:33 1991 */
  1136. /**/  while (is_cons(args)) {
  1137. /**/    ARG_0(stacktop) = a;
  1138. /**/    ARG_1(stacktop) = CAR(args); 
  1139. /**/    ARG_0(stackbase) = CDR(args);
  1140. /**/    if (Gf_binary_gt(stacktop) == nil) return(nil);
  1141. /**/    a = ARG_1(stacktop);
  1142. /**/    args = ARG_0(stackbase);
  1143. /**/  }
  1144. #endif /* jpff's version Fri Sep  6 17:51:33 1991 */
  1145.  
  1146.   return(lisptrue);
  1147. }
  1148. EUFUN_CLOSE
  1149.  
  1150. EUFUN_1( Fn_lt_or_equal, args)
  1151. {
  1152.   LispObject a;
  1153.  
  1154.   if (!is_cons(args))
  1155.     CallError(stacktop,"<=: insufficient arguments",args,NONCONTINUABLE);
  1156.  
  1157.   a = CAR(args); args = CDR(args);
  1158.  
  1159.   STACK_TMP(args);
  1160.   if (!is_cons(args)) return(lisptrue);
  1161.  
  1162.   while (is_cons(args)) {
  1163.     ARG_0(stacktop) = a;
  1164.     ARG_1(stacktop) = CAR(args);
  1165.     if (Gf_binary_lt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1166.       return nil;
  1167.     a = CAR(args);
  1168.  
  1169.     args = CDR(args);
  1170.     ARG_0(stackbase) = args;
  1171.   }
  1172.  
  1173.   return(lisptrue);
  1174. }
  1175. EUFUN_CLOSE
  1176.  
  1177. EUFUN_1( Fn_gt_or_equal, args)
  1178. {
  1179.   LispObject a;
  1180.  
  1181.   if (!is_cons(args))
  1182.     CallError(stacktop,">=: insufficient arguments",args,NONCONTINUABLE);
  1183.  
  1184.   a = CAR(args); args = CDR(args);
  1185.   ARG_0(stackbase)=args;
  1186.   if (!is_cons(args)) return(lisptrue);
  1187.  
  1188.   while (is_cons(args)) {
  1189.     ARG_0(stacktop) = a;
  1190.     ARG_1(stacktop) = CAR(args);
  1191.     if (Gf_binary_gt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1192.       return nil;
  1193.     a = CAR(args);
  1194.     args = CDR(args);
  1195.     ARG_0(stackbase) = args;
  1196.   }
  1197.  
  1198.   return(lisptrue);
  1199. }
  1200. EUFUN_CLOSE
  1201.  
  1202. LispObject generic_max;
  1203.  
  1204. EUFUN_2(Gf_max, a, b)
  1205. {
  1206.   return(generic_apply_2(stackbase, generic_max, a, b));
  1207. }
  1208. EUFUN_CLOSE
  1209.  
  1210. EUFUN_2(Md_max_Number_Number, a, b)
  1211. {
  1212.   if (EUCALL_2(Gf_binary_lt, a,b) != nil) return(ARG_1(stackbase));
  1213.   return(ARG_0(stackbase));
  1214. }
  1215. EUFUN_CLOSE
  1216.  
  1217. EUFUN_1( Fn_min, a)
  1218. {
  1219.   LispObject ans,xxx;
  1220.   while (!is_cons(a))
  1221.     a = CallError(stacktop,"Too few arguments for min ",a,CONTINUABLE);
  1222.   ans = CAR(a);
  1223.   a = CDR(a);
  1224.   while (!is_number(ans))
  1225.     ans = CallError(stacktop,"Non numeric argument for min ",ans,CONTINUABLE);
  1226.   while (a != nil) {
  1227.     LispObject b = CAR(a);
  1228.     while (!is_number(b)) 
  1229.       b = CallError(stacktop,"Non numeric argument for min ",b,CONTINUABLE);
  1230.     ARG_0(stackbase) = a;
  1231.     STACK_TMP(ans);
  1232.     STACK_TMP(b);
  1233.     ARG_0(stacktop) = ans;
  1234.     ARG_1(stacktop) = b;
  1235.     xxx = Md_max_Number_Number(stacktop);
  1236.     UNSTACK_TMP(b);
  1237.     UNSTACK_TMP(ans);
  1238.     if (xxx == ans)
  1239.       ans = b;
  1240.     else /*ans = ans */;
  1241.     a = CDR(ARG_0(stackbase));
  1242.   }
  1243.   return(ans);
  1244. }
  1245. EUFUN_CLOSE
  1246.  
  1247. EUFUN_1( Fn_max, a)
  1248. {
  1249.   LispObject ans,xxx;
  1250.   while (!is_cons(a))
  1251.     a = CallError(stacktop,"Too few arguments for max ",a,CONTINUABLE);
  1252.   ans = CAR(a);
  1253.   a = CDR(a);
  1254.   while (!is_number(ans))
  1255.     ans = CallError(stacktop,"Non numeric argument for max ",ans,CONTINUABLE);
  1256.   while (a != nil) {
  1257.     LispObject b = CAR(a);
  1258.     while (!is_number(b)) 
  1259.       b = CallError(stacktop,"Non numeric argument for max ",b,CONTINUABLE);
  1260.     ARG_0(stackbase) = a;
  1261.     STACK_TMP(ans);
  1262.     STACK_TMP(b);
  1263.     ARG_0(stacktop) = ans;
  1264.     ARG_1(stacktop) = b;
  1265.     xxx = Md_max_Number_Number(stacktop);
  1266.     UNSTACK_TMP(b); 
  1267.     UNSTACK_TMP(ans);
  1268.     if (xxx == b)
  1269.       ans = b;
  1270.     else /* ans = ans */;
  1271.     a = CDR(ARG_0(stackbase));
  1272.   }
  1273.   return(ans);
  1274. }
  1275. EUFUN_CLOSE
  1276.  
  1277. /* *************************************************************** */
  1278. /* COMPLEX NUMBERS                                                 */
  1279. /* *************************************************************** */
  1280.  
  1281. EUFUN_2( Fn_Make_Rectangular, x, y)
  1282. {
  1283.   while (!is_number(x) || (typeof(x)== TYPE_COMPLEX))
  1284.     x = CallError(stacktop,"make-rectangular: first argument not valid number",
  1285.           x,CONTINUABLE);
  1286.   while (!is_number(y) || (typeof(y)==TYPE_COMPLEX))
  1287.     y = CallError(stacktop,"make-rectangular: second argument not valid number",
  1288.           y,CONTINUABLE);
  1289.   return allocate_complex(stackbase,x,y);
  1290. }
  1291. EUFUN_CLOSE
  1292.  
  1293. EUFUN_1( Fn_Real_Part, obj)
  1294. {
  1295.   while (!is_number(obj))
  1296.     obj = CallError(stacktop,"Not a number in real-part",obj,CONTINUABLE);
  1297.   if (typeof(obj)==TYPE_COMPLEX)
  1298.     return obj->COMPLEX.real;
  1299.   else return obj;
  1300. }
  1301. EUFUN_CLOSE
  1302.  
  1303. EUFUN_1( Fn_Imaginary_Part, obj)
  1304. {
  1305.   while (!is_number(obj))
  1306.     obj = CallError(stacktop,"Not a number in imaginary-part",obj,CONTINUABLE);
  1307.   if (typeof(obj)==TYPE_COMPLEX)
  1308.     return obj->COMPLEX.imaginary;
  1309.   else return allocate_float(stackbase,(double)0.0);
  1310. }
  1311. EUFUN_CLOSE
  1312.  
  1313. /* *************************************************************** */
  1314. /* RATIONAL NUMBERS                                                */
  1315. /* *************************************************************** */
  1316.  
  1317. EUFUN_1( Fn_Numerator, obj)
  1318. {
  1319.   while (!is_number(obj))
  1320.     obj = CallError(stacktop,"Not a number in numerator",obj,CONTINUABLE);
  1321.   if (typeof(obj)==TYPE_RATIONAL)
  1322.     return obj->RATIO.numerator;
  1323.   else return obj;
  1324. }
  1325. EUFUN_CLOSE
  1326.  
  1327. EUFUN_1( Fn_Denominator, obj)
  1328. {
  1329.   while (!is_number(obj))
  1330.     obj = CallError(stacktop,"Not a number in denominator",obj,CONTINUABLE);
  1331.   if (typeof(obj)==TYPE_RATIONAL)
  1332.     return obj->RATIO.denominator;
  1333.   else return allocate_integer(stackbase, 1);
  1334. }
  1335. EUFUN_CLOSE
  1336.  
  1337.  
  1338.  
  1339. /* *************************************************************** */
  1340. /* Initialisation of this section                                  */
  1341. /* *************************************************************** */
  1342.  
  1343. #define ARITH_ENTRIES 75
  1344. MODULE Module_arith;
  1345. LispObject Module_arith_values[ARITH_ENTRIES];
  1346.  
  1347. void initialise_arith(LispObject *stacktop)
  1348. {
  1349.   extern LispObject generic_equal;
  1350.  
  1351.   open_module(stacktop,
  1352.           &Module_arith,
  1353.           Module_arith_values,
  1354.           "arith",
  1355.           ARITH_ENTRIES);
  1356.  
  1357.   (void) make_module_function(stacktop,"numberp",Fn_numberp,1);
  1358.  
  1359.   generic_binary_plus 
  1360.     = make_wrapped_module_generic(stacktop,"binary-plus",2,Gf_binary_plus);
  1361.   add_root(&generic_binary_plus);
  1362.   (void) make_module_function(stacktop,"generic_binary_plus,Number,Number",
  1363.                   Md_binary_plus_Object_Object,2
  1364.                   );
  1365.  
  1366. #ifndef WITH_BIGNUMS
  1367.   (void) make_module_function(stacktop,"generic_binary_plus,Integer,Integer",
  1368.                   Md_binary_plus_Integer_Integer,2
  1369.                   );
  1370. #endif
  1371.  
  1372.   (void) make_module_function(stacktop,"+",Fn_nary_plus,-1);
  1373.  
  1374.   generic_binary_difference 
  1375.     = make_wrapped_module_generic(stacktop,"binary-difference",2,Gf_binary_difference);
  1376.   add_root(&generic_binary_difference);
  1377.   (void) make_module_function(stacktop,"generic_binary_difference,Number,Number",
  1378.                   Md_binary_difference_Object_Object,2
  1379.                   );
  1380.  
  1381. #ifndef WITH_BIGNUMS
  1382.   (void) make_module_function(stacktop,"generic_binary_difference,Integer,Integer",
  1383.                   Md_binary_difference_Integer_Integer,2
  1384.                   );
  1385. #endif
  1386.  
  1387.   (void) make_module_function(stacktop,"-",Fn_nary_difference,-1);
  1388.  
  1389.   generic_binary_times 
  1390.     = make_wrapped_module_generic(stacktop,"binary-times",2,Gf_binary_times);
  1391.   add_root(&generic_binary_times);
  1392.   (void) make_module_function(stacktop,"generic_binary_times,Number,Number",
  1393.                   Md_binary_times_Object_Object,2
  1394.                   );
  1395.  
  1396. #ifndef WITH_BIGNUMS
  1397.   (void) make_module_function(stacktop,"generic_binary_times,Integer,Integer",
  1398.                   Md_binary_times_Integer_Integer,2
  1399.                   );
  1400. #endif
  1401.  
  1402.   (void) make_module_function(stacktop,"*",Fn_nary_times,-1);
  1403.  
  1404.   generic_binary_divide 
  1405.     = make_wrapped_module_generic(stacktop,"binary-divide",2,Gf_binary_divide);
  1406.   add_root(&generic_binary_divide);
  1407.   (void) make_module_function(stacktop,"generic_binary_divide,Number,Number",
  1408.                   Md_binary_divide_Object_Object,2
  1409.                   );
  1410. /*
  1411.   (void) make_module_function(stacktop,generic_binary_divide,
  1412.                   Md_binary_divide_Integer_Integer,
  1413.                   Integer,Integer);
  1414. */
  1415.   (void) make_module_function(stacktop,"/",Fn_nary_divide,-1);
  1416.  
  1417.   generic_binary_gcd 
  1418.     = make_wrapped_module_generic(stacktop,"binary-gcd",2,Gf_binary_gcd);
  1419.   add_root(&generic_binary_gcd);
  1420.   (void) make_module_function(stacktop,"generic_binary_gcd,Integer,Integer",
  1421.                   Md_binary_gcd_Integer_Integer,2
  1422.                   );
  1423.   (void) make_module_function(stacktop,"gcd",Fn_gcd,-1);
  1424.   generic_binary_lcm 
  1425.     = make_wrapped_module_generic(stacktop,"binary-lcm",2,Gf_binary_lcm);
  1426.   add_root(&generic_binary_lcm);
  1427.   (void) make_module_function(stacktop,"generic_binary_lcm,Integer,Integer",
  1428.                   Md_binary_lcm_Integer_Integer,2
  1429.                   );
  1430.   (void) make_module_function(stacktop,"lcm",Fn_lcm,-1);
  1431.  
  1432.   generic_eqn = make_wrapped_module_generic(stacktop,"=",2,Gf_eqn);
  1433.   add_root(&generic_eqn);
  1434.   (void) make_module_function(stacktop,"generic_eqn,Number,Number",
  1435.                   Md_eqn_Number_Number,2
  1436.                   );
  1437.   (void) make_module_function(stacktop,"generic_equal,Number,Number",
  1438.                   Gf_eqn,2
  1439.                   );
  1440.  
  1441.   generic_zerop = make_wrapped_module_generic(stacktop,"zerop",1,Gf_zerop);
  1442.   add_root(&generic_zerop);
  1443.   (void) make_module_function(stacktop,"generic_zerop,Number", Md_zerop_Number,1);
  1444.  
  1445.   generic_abs = make_wrapped_module_generic(stacktop,"abs",1,Gf_abs);
  1446.   add_root(&generic_abs);
  1447.   (void) make_module_function(stacktop,"generic_abs,Number",Md_abs_Number,1);
  1448.  
  1449.   /* Maths constants... */
  1450.  
  1451.   (void) make_module_entry(stacktop, "pi",allocate_float(stacktop,(double) 3.141592653589794));
  1452.   (void) make_module_entry(stacktop, "e",allocate_float(stacktop,(double) 2.718281828459046));
  1453.  
  1454.   (void) make_module_function(stacktop,"single-precision-integer-p",Fn_fixnump,1);
  1455.   (void) make_module_function(stacktop,"oddp",Fn_oddp,1);
  1456.   (void) make_module_function(stacktop,"evenp",Fn_evenp,1);
  1457.   (void) make_module_function(stacktop,"floatp",Fn_floatp,1);
  1458.   (void) make_module_function(stacktop,"floor",Fn_floor,1);
  1459.   (void) make_module_function(stacktop,"ceiling",Fn_ceiling,1);
  1460.   (void) make_module_function(stacktop,"sin",Fn_sin,1);
  1461.   (void) make_module_function(stacktop,"cos",Fn_cos,1);
  1462.   (void) make_module_function(stacktop,"exp",Fn_exp,1);
  1463.   (void) make_module_function(stacktop,"acos",Fn_acos,1);
  1464.   (void) make_module_function(stacktop,"asin",Fn_asin,1);
  1465.   (void) make_module_function(stacktop,"atan",Fn_atan,1);
  1466.   (void) make_module_function(stacktop,"atan2",Fn_atan2,2);
  1467.   (void) make_module_function(stacktop,"tan",Fn_tan,1);
  1468.   (void) make_module_function(stacktop,"acosh",Fn_acosh,1);
  1469.   (void) make_module_function(stacktop,"asinh",Fn_asinh,1);
  1470.   (void) make_module_function(stacktop,"atanh",Fn_atanh,1);
  1471.   (void) make_module_function(stacktop,"cosh",Fn_cosh,1);
  1472.   (void) make_module_function(stacktop,"sinh",Fn_sinh,1);
  1473.   (void) make_module_function(stacktop,"tanh",Fn_tanh,1);
  1474.   (void) make_module_function(stacktop,"log",Fn_log,-1);
  1475.  
  1476.   (void) make_module_function(stacktop,"quotient",Fn_quotient,2);
  1477.   (void) make_module_function(stacktop,"remainder",Fn_remainder,2);
  1478.   (void) make_module_function(stacktop,"modulo",Fn_remainder,2);
  1479.  
  1480.   generic_binary_lt 
  1481.     = make_wrapped_module_generic(stacktop,"binary-lt",2,Gf_binary_lt);
  1482.     add_root(&generic_binary_lt);
  1483.   (void) make_module_function(stacktop,"generic_binary_lt,Number,Number",
  1484.                   Md_binary_lt_Number,2
  1485.                   );
  1486.   (void) make_module_function(stacktop,"generic_binary_lt,Integer,Integer",
  1487.                   Md_binary_lt_Integer,2
  1488.                   );
  1489.   (void) make_module_function(stacktop,"<",Fn_lt,-1);
  1490.  
  1491.   generic_binary_gt 
  1492.     = make_wrapped_module_generic(stacktop,"binary-gt",2,Gf_binary_gt);
  1493.   add_root(&generic_binary_gt);
  1494.   (void) make_module_function(stacktop,"generic_binary_gt,Number,Number",
  1495.                   Md_binary_gt_Number,2
  1496.                   );
  1497.   (void) make_module_function(stacktop,"generic_binary_gt,Integer,Integer",
  1498.                   Md_binary_gt_Integer,2
  1499.                   );
  1500.   (void) make_module_function(stacktop,">",Fn_gt,-1);
  1501.  
  1502.   (void) make_module_function(stacktop,"<=",Fn_lt_or_equal,-1);
  1503.   (void) make_module_function(stacktop,">=",Fn_gt_or_equal,-1);
  1504.  
  1505.   (void) make_module_function(stacktop,"max",Fn_max,-1);
  1506.   (void) make_module_function(stacktop,"min",Fn_min,-1);
  1507.  
  1508.   (void) make_module_function(stacktop,"truncate",Fn_truncate,1);
  1509.   (void) make_module_function(stacktop,"round",Fn_round,1);
  1510.  
  1511.   (void) make_module_function(stacktop,"real-part",Fn_Real_Part,1);
  1512.   (void) make_module_function(stacktop,"imaginary-part",Fn_Imaginary_Part,1);
  1513.   (void) make_module_function(stacktop,"make-rectangular",Fn_Make_Rectangular,2);
  1514.  
  1515.   (void) make_module_function(stacktop,"numerator",Fn_Numerator,1);
  1516.   (void) make_module_function(stacktop,"denominator",Fn_Denominator,1);
  1517.   
  1518.   /* PAB added */
  1519.   (void) make_module_function(stacktop,"sqrt",Fn_sqrt,1);
  1520.   
  1521.   close_module();
  1522.  
  1523. }
  1524.